home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / state.c < prev    next >
C/C++ Source or Header  |  1992-10-26  |  7KB  |  276 lines
  1. /* ******************************************************************** */
  2. /* state.c           Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Lisp state                                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: state.c,v 1.7 1992/07/13 13:15:56 djb Exp $
  9.  *
  10.  * $Log: state.c,v $
  11.  * Revision 1.7  1992/07/13  13:15:56  djb
  12.  * ifdef DGC (compacting mark+sweep collector)
  13.  * then zero unused portions of c and gc-stack
  14.  * before gc (tidy_stacks())
  15.  *
  16.  * Revision 1.6  1992/01/29  13:48:20  pab
  17.  * additional debug info for sysV
  18.  *
  19.  * Revision 1.5  1992/01/05  22:48:22  pab
  20.  * Minor bug fixes, plus BSD version
  21.  *
  22.  * Revision 1.4  1991/12/22  15:14:35  pab
  23.  * Xmas revision
  24.  *
  25.  * Revision 1.3  1991/11/15  13:45:35  pab
  26.  * copyalloc rev 0.01
  27.  *
  28.  * Revision 1.2  1991/09/11  12:07:42  pab
  29.  * 11/9/91 First Alpha release of modified system
  30.  *
  31.  * Revision 1.1  1991/08/12  16:50:01  pab
  32.  * Initial revision
  33.  *
  34.  * Revision 1.6  1991/02/13  18:25:07  kjp
  35.  * Pass.
  36.  *
  37.  */
  38.  
  39. /*
  40.  * Change Log:
  41.  *   Version 1, May 1990
  42.  */
  43.  
  44. /*
  45.  
  46.  * This holds the "state" data and operations - should be system
  47.  * independant and encapsulte ALL continuation operations...
  48.  
  49.  */
  50.  
  51. #include "funcalls.h"
  52. #include "defs.h"
  53. #include "structs.h"
  54. #include "error.h"
  55. #include "global.h"
  56.  
  57. #include "calls.h"
  58. #include "modboot.h"
  59. #include "allocate.h"
  60. #include "modules.h"
  61.  
  62. #include "state.h"
  63.  
  64. /* Fixed outside of a context switch... */
  65.  
  66. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_current_thread);
  67. SYSTEM_THREAD_SPECIFIC_DECLARATION(int*,state_stack_base);
  68. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject*,state_gc_stack_base);
  69.  
  70. /* Forever wandering... */
  71.  
  72. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject*,state_gc_stack_pointer);
  73. SYSTEM_THREAD_SPECIFIC_DECLARATION(Env,state_dynamic_env);
  74. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_last_continue);
  75. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,state_handler_stack);
  76.  
  77. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,dp);
  78. SYSTEM_THREAD_SPECIFIC_DECLARATION(LispObject,dlp);
  79.  
  80. /* Notionally, the registers hold the machine state */
  81.  
  82. /*
  83.  * Loads the lisp specific state of the world into a continuation struct
  84.  */
  85.  
  86. LispObject save_state(LispObject *stacktop,LispObject cont)
  87. {
  88. #ifndef NODEBUG
  89.   extern int gc_paranoia;
  90.  
  91.   if (gc_paranoia)
  92.     fprintf(stderr,"{Save: 0x%x->0x%x[%d]}",
  93.         SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_base),
  94.         stacktop,(stacktop-SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_base))/sizeof(LispObject));
  95. #endif
  96.   cont->CONTINUE.gc_stack_pointer 
  97.     = stacktop;
  98.  
  99.   cont->CONTINUE.dynamic_env
  100.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_dynamic_env);
  101.  
  102.   cont->CONTINUE.last_continue
  103.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue);
  104.  
  105.   cont->CONTINUE.handler_stack
  106.     = SYSTEM_THREAD_SPECIFIC_VALUE(state_handler_stack);
  107.  
  108.   cont->CONTINUE.dp 
  109.     = SYSTEM_THREAD_SPECIFIC_VALUE(dp);
  110.  
  111.   return(cont);
  112.  
  113. }
  114.  
  115. /*
  116.  * Similarly, the other way around...
  117.  */
  118.  
  119. void change_state(LispObject cont)
  120. {
  121.   
  122.   SYSTEM_THREAD_SPECIFIC_VALUE(state_gc_stack_pointer)
  123.     = cont->CONTINUE.gc_stack_pointer;
  124.  
  125.   SYSTEM_THREAD_SPECIFIC_VALUE(state_dynamic_env)
  126.     = cont->CONTINUE.dynamic_env;
  127.  
  128.   SYSTEM_THREAD_SPECIFIC_VALUE(state_last_continue)
  129.     = cont->CONTINUE.last_continue;
  130.  
  131.   SYSTEM_THREAD_SPECIFIC_VALUE(state_handler_stack)
  132.     = cont->CONTINUE.handler_stack;
  133.  
  134.   SYSTEM_THREAD_SPECIFIC_VALUE(dp)
  135.     = cont->CONTINUE.dp;
  136.  
  137.   SYSTEM_THREAD_SPECIFIC_VALUE(dlp)
  138.     = cont->CONTINUE.dp;
  139. }
  140.  
  141. /*
  142.  
  143.  * Set a continuation...
  144.  *
  145.  * Note: these are just the lisp equivalents of setjmp and longjmp -
  146.  *       they do not deal with killing other continuations apart from
  147.  *       themselves or handling unwind protects.
  148.  
  149.  * Note also that all this hackery is required to provide abstraction
  150.  * 'cos were it a standard function call, the stack would get nobbled.
  151.  
  152.  */
  153.  
  154. int set_continue_1(LispObject *stacktop,LispObject cont)
  155. {
  156.  
  157.   cont->CONTINUE.thread = SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread);
  158.  
  159.   save_state(stacktop,cont);
  160.  
  161.   cont->CONTINUE.value = nil;
  162.  
  163.   return(TRUE);
  164.  
  165. }
  166.  
  167. int set_continue_2(LispObject cont)
  168. {
  169.  
  170.   /* Fix last continue... */
  171.  
  172.   LAST_CONTINUE() = cont;
  173.  
  174.   /* All set... */
  175.  
  176.   cont->CONTINUE.live = TRUE;
  177.  
  178.   return(FALSE);
  179.  
  180. }
  181.  
  182. void call_continue(LispObject *stacktop,LispObject cont,LispObject value)
  183. {
  184.   
  185.   if (!is_continue(cont)) {
  186.     printf("****BAD CONTINUATION**** type %d - waiting...\n",typeof(cont));
  187.     fflush(stdout);
  188.     exit(1);
  189.   }
  190.  
  191.   if (cont->CONTINUE.thread 
  192.       != SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread))
  193.     {    
  194.       fprintf(stderr,"Wrong thread: %x[%d] %x[%d]\n",SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread),
  195.           SYSTEM_THREAD_SPECIFIC_VALUE(state_current_thread)->THREAD.header.gc,
  196.           cont->CONTINUE.thread,cont->CONTINUE.thread->THREAD.header.gc);
  197.       CallError(stacktop,"call continuation: wrong thread",cont,NONCONTINUABLE);
  198.     }
  199.  
  200.   cont->CONTINUE.live = FALSE;
  201.  
  202.   /* Already on current thread... */
  203.  
  204.   change_state(cont);
  205.  
  206.   cont->CONTINUE.value = value;
  207.  
  208.  
  209.   longjmp(cont->CONTINUE.machine_state,TRUE);
  210.  
  211. }
  212.  
  213. #ifdef DGC
  214.  
  215. /* clear unused areas of c-stack and gc-stack so that c-gc will 
  216.    collect objects that were pointed to from within those areas */
  217.  
  218. void tidy_stacks(LispObject *stacktop)
  219. {
  220.   int *ptr;
  221.  
  222.   if (stacktop!=NULL)
  223.   {
  224. #ifndef NODEBUG
  225.     fprintf(stderr,"stacktop=%p, gc_stack_base=%p, gc_stack_size=%p\n",
  226.         stacktop,CURRENT_THREAD()->THREAD.gc_stack_base,
  227.         CURRENT_THREAD()->THREAD.gc_stack_size); 
  228.  
  229.     fprintf(stderr,"clearing %p of gc-stack\n",
  230.         (CURRENT_THREAD()->THREAD.gc_stack_base+
  231.          CURRENT_THREAD()->THREAD.gc_stack_size)-stacktop);
  232. #endif
  233.     for (ptr=(int *)(CURRENT_THREAD()->THREAD.gc_stack_base + 
  234.              CURRENT_THREAD()->THREAD.gc_stack_size); 
  235.      ptr>(int *)stacktop; 
  236.      ptr--)
  237.       *ptr=NULL;
  238.   }  
  239. #ifndef NODEBUG
  240.   fprintf(stderr,"stack_base=%p, &ptr=%p\n",
  241.       (int *)(CURRENT_THREAD()->THREAD.stack_base), &ptr);
  242.  
  243.   fprintf(stderr,"clearing %p of c-stack out of %p\n",
  244.       (int *)&ptr - (int *)(CURRENT_THREAD()->THREAD.stack_base),
  245.       (int *)(CURRENT_THREAD()->THREAD.stack_size));
  246. #endif
  247.   for (ptr=(int *)(CURRENT_THREAD()->THREAD.stack_base);
  248.        ptr<(int *)&ptr; /* an arbitrary local variable */
  249.        ptr++)
  250.     *ptr=NULL;
  251.   }
  252. #endif
  253.  
  254. /*
  255.  
  256.  * Load a thread into the system ready for execution...
  257.  
  258.  * returns the new GC stacktop
  259.  */
  260.  
  261. LispObject* load_thread(LispObject thread)
  262. {
  263.  
  264.   CURRENT_THREAD() = thread;
  265.  
  266.   STACK_BASE()    = thread->THREAD.stack_base;
  267.   GC_STACK_BASE() = thread->THREAD.gc_stack_base;
  268.   
  269.   /* Just the flexible stuff left... */
  270.  
  271.   change_state(thread->THREAD.state);
  272.  
  273.   return (thread->THREAD.state->CONTINUE.gc_stack_pointer);
  274. }
  275.  
  276.